; ORIGINAL: 3dt2.1/examples/geometry.scm
; $Id: geometry.scm,v 1.4 1997/04/30 20:24:11 jread Exp $
;;=====================================================
; Purpose---
;    Implement scheme procedures used for geometry construction in the MFC sample
;;   implementation of ACIS
;;=====================================================

(require 'rubber-band "rbutl.scm")
(require 'cmd "cmd.scm")

(define prompt (lambda args '()))

;;=============================================================================
;; helper procedure to create a rectangle
(define (make-rectangle p0 pt2)
  (let ((elist '())
        (p1 (position (position:x pt2) (position:y p0) (position:z p0)))
        (p2 (position (position:x pt2) (position:y pt2) (position:z p0)))
        (p3 (position (position:x p0) (position:y pt2) (position:z p0)))
        )
    (roll:mark-start)
    (set! elist (list
                  (edge:linear p0 p1)
                  (edge:linear p1 p2)
                  (edge:linear p2 p3)
                  (edge:linear p3 p0)
                  ))
    (roll:mark-end)
    elist))

;;=============================================================================
;; Actvate line creation command
(define (line-cmd)
  (cmd:set
    `(edge:linear
       ,(arg:desc %point
                  '(prompt "Indicate start of line")
                  (lambda (p) (rbd:line #t p))
                  )
       ,(arg:desc %point
                  '(prompt "Indicate end of line")
                  '(rbd:clear)
                  )
       )))

;;=============================================================================
;; Actvate circle creation command. creates circles given the center position
;; and an edge position.
(define (circle-cmd)
  (cmd:set
    `(edge:circular-center-rim
       ,(arg:desc %point
                  '(prompt "Indicate center of circle")
                  (lambda (p) (rbd:add (rb:circle p)))
                  )
       ,(arg:desc %point
                  '(prompt "Indicate position on edge of circle")
                  '(rbd:clear)
                  )
       )))

;;=============================================================================
;; Actvate rectangle creation command
(define (rectangle-cmd)
  (cmd:set
    `(make-rectangle
       ,(arg:desc %point
                  '(prompt "Indicate first corner of rectangle")
                  (lambda (p) (rbd:rectangle #t p))
                  )
       ,(arg:desc %point
                  '(prompt "Indicate second corner of rectangle")
                  '(rbd:clear)
                  )
       )))

;;=============================================================================
;; Actvate edge filleting command
(define (fillet-cmd radius trim1 trim2)
  (cmd:set
    `(edge:fillet
       ,(arg:desc %edger
                  '(prompt "Select first edge")
                  #f
                  )
       ,(arg:desc %edger
                  '(prompt "Select second edge")
                  #f
                  )
       ,radius ,trim1 ,trim2
       )))

;;=============================================================================
;; Actvate edge trimming command
(define (trim-cmd)
  (cmd:set
    `(edge:trim
       ,(arg:desc %edger
                  '(prompt "Select edge to trim")
                  #f
                  )
       ,(arg:desc %edger
                  '(prompt "Select bound edge")
                  #f
                  )
       )))

;;=============================================================================
;; Actvate command to trim two edges to their intersection
(define (trim2-cmd)
  (cmd:set
    `(edge:trim-intersect
       ,(arg:desc %edger
                  '(prompt "Select first edge")
                  #f
                  )
       ,(arg:desc %edger
                  '(prompt "Select second edge")
                  #f
                  )
       )))

;;=============================================================================
;; Actvate command to trim out the middle of an edge
(define (trim-middle-cmd)
  (cmd:set
    `(edge:trim-middle
       ,(arg:desc %edger
                  '(prompt "Select curve to trim")
                  #f
                  )
       ,(arg:desc %edger
                  '(prompt "Select first bound")
                  #f
                  )
       ,(arg:desc %edger
                  '(prompt "Select second bound")
                  #f
                  )
       )))

;;=============================================================================
;; Actvate block creation comand
(define (block-cmd)
  (let ((pt0 '())
        (pt1 '())
        )
    (cmd:set
      `(,(lambda (p0 p1 p2)
           (let* ((pt1 (position:project-to-plane p1 p0 (gvector 0 0 1)))
                  (height (- (position:z p2) (position:z p0)))
                  (pt2 (position:offset pt1 (gvector 0 0 height))))
             (solid:block p0 pt2)
             ))
         ,(arg:desc %point
                    '(prompt "Indicate first corner of block")
                    (lambda (p) (set! pt0 p) (rbd:rectangle #t p))
                    )
         ,(arg:desc %point
                    '(prompt "Indicate second corner of base of block")
                    (lambda (p)
                      (set! pt1 p)
                      (rbd:clear)
                      (rbd:add (rb:block pt0 p)))
                    )
         ,(arg:desc (lambda (pe) (pick:position pe pt1 (gvector 0 -1 0)))
                    '(prompt "Indicate top of block")
                    '(rbd:clear)
                    )
         ))))

;;=============================================================================
;; Actvate cylinder creation comand
(define (cylinder-cmd)
  (let ((pt0 '())
        (radius '())
        )
    (cmd:set
      `(,(lambda (p0 p1 p2)
           (solid:cylinder p0 (position:project-to-line p2 p0 (gvector 0 0 1)) radius)
           )
         ,(arg:desc %point
                    '(prompt "Indicate center of base")
                    (lambda (p) (set! pt0 p) (rbd:add (rb:circle p)))
                    )
         ,(arg:desc %point
                    '(prompt "Indicate radius of base")
                    (lambda (p)
                      (set! radius (position:distance pt0
                                                      (position:project-to-plane p pt0 (gvector 0 0 1))))
                      (rbd:clear)
                      (rbd:add (rb:cylinder pt0 radius))
                      )
                    #f
                    )
         ,(arg:desc (lambda (pe) (pick:position pe pt0 (gvector 0 -1 0)))
                    '(prompt "Indicate top of cylinder")
                    '(rbd:clear)
                    )
         ))))

;;=============================================================================
;; Actvate sphere creation comand
(define (sphere-cmd)
  (cmd:set
    `(,(lambda (center edge)
         (solid:sphere center (position:distance center edge))
         )
       ,(arg:desc %point
                  '(prompt "Indicate center of sphere")
                  (lambda (p) (rbd:add (rb:circle p)))
                  )
       ,(arg:desc %point
                  '(prompt "Indicate position on surface of sphere")
                  '(rbd:clear)
                  )
       )))

;;=============================================================================
;; Actvate solid unite command
(define (unite-cmd)
  (cmd:set
    `(solid:unite
       ,(arg:desc %pick
                  '(prompt "Unite: pick first body")
                  #f
                  )
       ,(arg:desc %pick
                  '(prompt "Unite: pick second body")
                  #f
                  )
       )))

;;=============================================================================
;; Actvate solid subtract command
(define (subtract-cmd)
  (cmd:set
    `(solid:subtract
       ,(arg:desc %pick
                  '(prompt "Subtract: pick first body")
                  #f
                  )
       ,(arg:desc %pick
                  '(prompt "Subtract: pick second body")
                  #f
                  )
       )))

;;=============================================================================
;; Actvate solid intersect command
(define (intersect-cmd)
  (cmd:set
    `(solid:intersect
       ,(arg:desc %pick
                  '(prompt "Intersect: pick first body")
                  #f
                  )
       ,(arg:desc %pick
                  '(prompt "Intersect: pick second body")
                  #f
                  )
       )))

;;=============================================================================
;; Actvate blend edges command
(define (blend-cmd radius)
  (cmd:set
    `(solid:blend-edges
       ,(arg:desc %edge
                  '(prompt "Pick edge to blend")
                  #f
                  #t
                  )
       ,radius
       )))
